Spectran Validation

Preface

This document compares the results for ten spectra across the Spectral Analysis Shiny application, the online app luox by Manuel Spitschan, and the free CIE S 026 alpha-opic Toolbox. The main goal of this document is to validate the Spectral Analysis application against the methods the CIE has provided or already validated. We will look at results for illuminance, α-opic irradiance, and α-opic equivalent daylight (D65) illuminance. We will also compare the irradiance (only with the toolbox) and Correlated Color Temperature (CCT) and Color-Rendering Index (CRI) (only with the luox app), which are only available in one of the two validated sources. All three sources offer more parameters, but those are either not part of both the shiny application and a validated source or are derivatives of the above-mentioned parameters. Some spectral data files had negative input values (coming straight from the spectrometer export after measurement). The Shiny app replaces these values with zero, whereas the CIE toolbox gives an error for these values. Here, the values were manually set to zero in the toolbox user input mask. The luox app gives no error for negative values, but it is not exactly known how the app deals with those values (see below under Section 4 for more on that).

Table Preparation

The following code chunks prepare the tables shown below. The first chunk loads the necessary libraries:

Code

#Setup code, data import, initial data selection to get to one comparison file
#read all libraries
library(tidyverse)
library(readxl)
library(magick)
library(gt)
library(here)
library(cowplot)

#Plottheme
theme_set(theme_cowplot(font_size = 10, font_family = "sans"))

The following chunk loads all data:

Code

#Data Import -------------------

##read all filenames and paths of spectra
spectra <- 
  tibble(
    file_names = list.files("./Original_Spectra"),
    file_path = paste0("./Original_Spectra/", list.files("./Original_Spectra"))
    )

##read the csv-files to that spectra
spectra <- 
  spectra %>% 
  rowwise() %>% 
  mutate(Spectrum = list(read_csv(file_path)))

##create a name column 
spectra <- 
  spectra %>% 
  mutate(spectrum_name = str_replace(file_names, ".csv", ""))

##read the results from the luox app
spectra <- 
  spectra %>% 
  rowwise() %>% 
  mutate(
    luox = list(
      read_csv(
        paste0("./Results_Luox_2022-10-21/", spectrum_name, 
               "/download-calc.csv")
        )
      )
    )

##read the results from the shiny app
###filepath
excel_file_path <- function(spectrum_name) {
  paste0(
    "./Results_ShinyApp/",
    {{ spectrum_name }}, 
    "/",
    {{ spectrum_name }}, 
    "_9_2022-10-20.xlsx"
    )
}
###list for each worksheet in the excel-file
spectra <- 
  spectra %>% 
  rowwise() %>% 
  mutate(
    shiny = list(
      list(
        Radiometrie = read_xlsx(
          excel_file_path(spectrum_name), 
          sheet = "Radiometrie"
          ),
        Photometrie = read_xlsx(
          excel_file_path(spectrum_name), 
          sheet = "Photometrie"
          ),
        Alpha = read_xlsx(
          excel_file_path(spectrum_name), 
          sheet = "Alpha-opisch"
          )
        )
      )
    ) 

##read the results from the CIE toolbox
spectra <- 
  spectra %>% 
  rowwise() %>% 
  mutate(
    toolbox = list(
      read_xlsx(
        paste0(
          "./Results_CIE_Toolbox/", 
          spectrum_name, 
          "/CIE S 026 alpha-opic Toolbox.xlsx"
          ), 
        sheet = "Outputs"
        )
      )
    )

The following chunk takes the relevant data for comparison out from the sources and puts them into one table per comparison spectrum:

Code

#Initial Data wrangling -------------------
##take the relevant datapoints from the luox results
### the relevant data in the luox results are in column 2, rows 1, 6 to 15, 22, 
### and 24
locations_luox <- c(1, 6:15, 22, 24)
spectra <- 
  spectra %>% 
  rowwise() %>% 
  mutate(
    excerpt = list(
      tibble(
        Name = luox %>% pull(1) %>% .[locations_luox],
        Results_luox = luox %>% pull(2) %>% .[locations_luox]
        )
      )
    )



###Add a row for irradiance, which is missing in the luox output
spectra <- 
  spectra %>% 
  mutate(
    excerpt = list(
      rbind(
        excerpt[1:11,], 
        c("Irradiance (mW ⋅ m⁻²)", NA), 
        excerpt[12:13,]
        )
      ),
    excerpt = list(
      excerpt %>% mutate(Results_luox = as.numeric(Results_luox))
    )
    )

##extract the relevant datapoints from the shiny app
### the relevant data in the shiny app results are in the list 
### - "Photometrie", column 3, row 1, 
### - "Alpha", column 3 to 7, row 1 to 2 (the order has to be adjusted in order 
###to match the luox data frame)
### - "Radiometrie, column 3, row 1, 
### - "Photometrie", column 3, row 4 to 5
shiny_extract <- function(data, sheet, column = Wert, rows) {
  data %>% .[[sheet]] %>% pull({{ column }}) %>% .[rows]
}
spectra <- 
  spectra %>% 
  rowwise() %>% 
  mutate(
    excerpt = list(
      cbind(
        excerpt[1],
        tibble(
        Results_shiny = as.numeric(
          c(
            shiny_extract(
              data = shiny, sheet = "Photometrie", rows = 1),
            shiny_extract(
              data = shiny, sheet = "Alpha", column = "Cyanopsin", rows = 2),
            shiny_extract(
              data = shiny, sheet = "Alpha", column = "Chloropsin", rows = 2),
            shiny_extract(
              data = shiny, sheet = "Alpha", column = "Erythropsin", rows = 2),
            shiny_extract(
              data = shiny, sheet = "Alpha", column = "Rhodopsin", rows = 2),
            shiny_extract(
              data = shiny, sheet = "Alpha", column = "Melanopsin", rows = 2),
            shiny_extract(
              data = shiny, sheet = "Alpha", column = "Cyanopsin", rows = 1),
            shiny_extract(
              data = shiny, sheet = "Alpha", column = "Chloropsin", rows = 1),
            shiny_extract(
              data = shiny, sheet = "Alpha", column = "Erythropsin", rows = 1),
            shiny_extract(
              data = shiny, sheet = "Alpha", column = "Rhodopsin", rows = 1),
            shiny_extract(
              data = shiny, sheet = "Alpha", column = "Melanopsin", rows = 1),
            shiny_extract(
              data = shiny, sheet = "Radiometrie", rows = 1),
            shiny_extract(
              data = shiny, sheet = "Photometrie", rows = c(4, 5))
            )
          )
        ),
        excerpt[2]
        )
      )
  )

##extract the relevant datapoints from the CIE Toolbox
### the relevant data in the toolbox are in 
### column 3, row 14
### column 1 to 5, row 20-> needs to be multiplied by a factor of 1000 to be in 
### mW, to which the other sources are scaled.
### column 1 to 5, row 32
### column 1, row 14 -> needs to be multiplied by a factor of 1000 to be in mW, 
### to which the other sources are scaled.
spectra <- 
  spectra %>% 
  mutate(
    excerpt = list(
      cbind(
        excerpt,
        tibble(
          Results_toolbox = as.numeric(
            c(
              toolbox %>% pull(3) %>% .[14],
              toolbox %>% {as.vector(.[20,])} %>% as.numeric %>% 
                magrittr::multiply_by(1000),
              toolbox %>% {as.vector(.[32,])},
              toolbox %>% pull(1) %>% .[14] %>% as.numeric %>% 
                magrittr::multiply_by(1000),
              NA, NA
              )
            )
          )
        )
      )
    )

The following chunk transforms the comparison tables for all spectra into one comprehensive table.

Code

#Putting the table together -------------------
##create a function that calculates the relative difference between the shiny 
##app-results, and another source
Deviation <- function(Results, Results2){
  if(!is.na({{ Results }}) & !is.na({{ Results2 }})){
  res <- 1- {{ Results }} / {{ Results2 }}
  res2 <- vec_fmt_scientific(res)
  if(res < 0) {
    paste0('<div style="color:red">', res2, '</div>')
  }
  else if(res == 0 ) {
    paste0('<div style="color:green">', res2, '</div>')
  }
  else {
    paste0('<div style="color:blue">', res2, '</div>')
  }

  }
  else NA
}

##new dataframe, unnested data, columns for relative difference
Results <- 
  spectra %>% 
  select(spectrum_name, excerpt) %>% 
  unnest(excerpt) %>% 
  rowwise() %>% 
  mutate(Dev_luox = Deviation(Results_luox, Results_shiny),
         Dev_toolbox = Deviation(Results_toolbox, Results_shiny)
         )

##pivoting the dataframe wider, so that each spectrum has only one row
Results <- 
  Results %>% 
  pivot_wider(
    id_cols = spectrum_name, 
    names_from = Name, 
    values_from = c(Results_shiny:Dev_toolbox),
    names_sep = "."
    )

##adding a placeholder for the spectrum picture, with the filepath
###filepath
pdf_file_path <- function(spectrum_name) {
  paste0("<img src='Results_ShinyApp/",
    {{ spectrum_name }}, 
    "/",
    {{ spectrum_name }}, 
    "_1_Radiometrie_2022-10-20.png' style=\'height:80px;\'>"
    )
}
###splicing the dataframes together
Results <- cbind(Results[,1], as_tibble_col(
  pdf_file_path(spectra$spectrum_name), column_name = "Picture"), Results[,-1])

The next chunk prepares the table output in a flexible way:

Code

#setting the table up -------------------

##names for the merging
merging_names <- spectra$excerpt[[1]]$Name
merging_names2 <- spectra$excerpt[[1]]$Name %>% str_replace("\\(", "<br>\\(")

##column names for renaming
col_names <- paste0("Results_shiny.", merging_names)
##creating a list with one entry per variable, named after the column name (to 
##be renamed later)
renaming <- rbind(merging_names2)
names(renaming) <- col_names
renaming <- renaming %>% as.list()
renaming <- map(renaming, md)

#creating a list with cells not to format by decimals
number_fmt_col <- 
  Results %>% select(!starts_with("Dev") & !Picture & !spectrum_name) %>% 
  names()

##function that does the merging
merging <- function(data, Name, condition = "difference") {
  if(condition == "difference"){
  data %>% cols_merge(columns = ends_with(Name, ignore.case = FALSE),
             pattern = "<div style='color:lightgrey'>shiny:</div>{1}<div
             style='color:lightgrey'>luox:</div>{4}<div style='color:lightgrey'>
             toolbox:</div>{5}")
  }
  else {
      data %>% cols_merge(columns = ends_with(Name, ignore.case = FALSE),
             pattern = "<div style='color:lightgrey'>shiny:</div>{1}<div
             style='color:lightgrey'>luox:</div>{2}<div style='color:lightgrey'>
             toolbox:</div>{3}")
  }
}

#creating a function for the gt table
comparison_table <- function(tt_text, fn_text, condition) {
gtobj <- Results %>% 
  gt(rowname_col = c("spectrum_name")) %>% 
  tab_header(title = md(paste0("**Validation Results: ",tt_text , "**"))) %>% 
  tab_footnote(footnote = fn_text)

for(i in seq_along(merging_names)) {
  gtobj <- gtobj %>% merging(merging_names[i], condition = condition)
}

gtobj <- gtobj %>%   
  fmt_markdown(columns = everything()) %>%
  fmt_number(
    columns = all_of(number_fmt_col),
    decimals = 3,
    sep_mark = "",
    pattern = "{x}<br>"
    ) %>%
  cols_align(align = "center") %>% 
  cols_label(.list = renaming) %>%
  sub_missing(missing_text = md("---<br>")) %>% 
  cols_width(
    Picture ~px(150),
    everything() ~ px(80)
  ) %>% 
  opt_align_table_header(align = "left") %>% 
  tab_options(table.font.size = "9px")

gtobj

}

Results

This section shows the validation results in two tables. The first table shows the results for the Shiny App per spectrum and parameter alongside the relative difference of the respective results from the luox app and the CIE Toolbox. The second table shows all results per spectrum and parameter. Note that the Shiny App does not provide a CRI [Ra] for the artificial EE_Spektrum and the LED_4000K_2, because they exceed the CIE limits for calculation.

Relative Differences

Code

#creating the gtable -------------------

#text for the subtitle
fn_text <- 
  md(paste0(
    "The first number in every cell shows the Result from the *Shiny* app, ",
    "<br>the second number the **relative** difference of the respective ",
    "result from the *luox* app, <br>whereas the third number shows the same ",
    "for the result from the *CIE S026 Toolbox*. <br><a style='color:green'>",
    "green</a> values indicate a zero difference, <a style='color:red'>red</a>",
    " a negative difference, and <a style='color:blue'>blue</a> a positive ",
    "difference. <br>All *Shiny* values are rounded to three decimals. <br>", 
    "Missing values or pairwise comparisons are indicated by a ---."))

tt_text <- "Relative Differences"

comparison_table(tt_text, fn_text, condition = "difference")

Validation Results: Relative Differences
	Picture	Illuminance (lx)	S-cone-opic irradiance (mW ⋅ m⁻²)	M-cone-opic irradiance (mW ⋅ m⁻²)	L-cone-opic irradiance (mW ⋅ m⁻²)	Rhodopic irradiance (mW ⋅ m⁻²)	Melanopic irradiance (mW ⋅ m⁻²)	S-cone-opic EDI (lx)	M-cone-opic EDI (lx)	L-cone-opic EDI (lx)	Rhodopic EDI (lx)	Melanopic EDI (lx)	Irradiance (mW ⋅ m⁻²)	CCT (K) - Robertson, 1968	Colour Rendering Index [Ra]
EE_Spektrum		shiny: 100.000 luox: −2.93 × 10−6 toolbox: −2.27 × 10−6	shiny: 75.641 luox: 0.00 toolbox: 5.11 × 10−15	shiny: 139.676 luox: 0.00 toolbox: 7.33 × 10−15	shiny: 163.891 luox: 2.51 × 10−9 toolbox: 3.66 × 10−15	shiny: 133.005 luox: 0.00 toolbox: 3.00 × 10−15	shiny: 120.131 luox: 0.00 toolbox: 4.66 × 10−15	shiny: 92.550 luox: −1.27 × 10−5 toolbox: −1.27 × 10−5	shiny: 95.945 luox: 1.81 × 10−5 toolbox: 1.81 × 10−5	shiny: 100.614 luox: 4.77 × 10−6 toolbox: 4.77 × 10−6	shiny: 91.747 luox: 2.47 × 10−6 toolbox: 2.47 × 10−6	shiny: 90.583 luox: 9.94 × 10−6 toolbox: 9.94 × 10−6	shiny: 549.443 luox: — toolbox: 7.44 × 10−15	shiny: 5453.666 luox: −1.78 × 10−15 toolbox: —	shiny: — luox: — toolbox: —
Fluoreszenz_NW		shiny: 100.000 luox: −2.93 × 10−6 toolbox: −2.27 × 10−6	shiny: 40.235 luox: 0.00 toolbox: 5.55 × 10−16	shiny: 125.328 luox: 0.00 toolbox: 3.33 × 10−16	shiny: 161.847 luox: 4.62 × 10−10 toolbox: 3.89 × 10−15	shiny: 90.644 luox: 4.46 × 10−8 toolbox: 1.55 × 10−15	shiny: 71.312 luox: 8.36 × 10−8 toolbox: 1.44 × 10−15	shiny: 49.229 luox: −1.27 × 10−5 toolbox: −1.27 × 10−5	shiny: 86.089 luox: 1.81 × 10−5 toolbox: 1.81 × 10−5	shiny: 99.360 luox: 4.77 × 10−6 toolbox: 4.77 × 10−6	shiny: 62.526 luox: 2.51 × 10−6 toolbox: 2.47 × 10−6	shiny: 53.772 luox: 1.00 × 10−5 toolbox: 9.94 × 10−6	shiny: 293.442 luox: — toolbox: 1.89 × 10−15	shiny: 3759.099 luox: 7.57 × 10−8 toolbox: —	shiny: 83.077 luox: 9.21 × 10−4 toolbox: —
Fluoreszenz_WW		shiny: 100.000 luox: −2.90 × 10−6 toolbox: −2.27 × 10−6	shiny: 23.471 luox: 0.00 toolbox: 2.78 × 10−15	shiny: 111.528 luox: 1.84 × 10−9 toolbox: 5.11 × 10−15	shiny: 164.806 luox: 1.78 × 10−8 toolbox: 3.33 × 10−15	shiny: 65.329 luox: 4.15 × 10−7 toolbox: 8.88 × 10−16	shiny: 44.754 luox: 9.02 × 10−7 toolbox: 1.11 × 10−15	shiny: 28.718 luox: −1.27 × 10−5 toolbox: −1.27 × 10−5	shiny: 76.610 luox: 1.81 × 10−5 toolbox: 1.81 × 10−5	shiny: 101.176 luox: 4.79 × 10−6 toolbox: 4.77 × 10−6	shiny: 45.064 luox: 2.88 × 10−6 toolbox: 2.47 × 10−6	shiny: 33.746 luox: 1.08 × 10−5 toolbox: 9.94 × 10−6	shiny: 284.770 luox: — toolbox: 2.22 × 10−15	shiny: 2676.108 luox: 2.20 × 10−7 toolbox: —	shiny: 82.394 luox: 2.29 × 10−4 toolbox: —
Halogen		shiny: 100.000 luox: −2.93 × 10−6 toolbox: −2.27 × 10−6	shiny: 22.648 luox: 0.00 toolbox: −2.22 × 10−16	shiny: 115.192 luox: 0.00 toolbox: 3.33 × 10−16	shiny: 166.103 luox: 4.51 × 10−9 toolbox: 3.11 × 10−15	shiny: 78.883 luox: 0.00 toolbox: 2.33 × 10−15	shiny: 61.492 luox: 0.00 toolbox: 2.00 × 10−15	shiny: 27.711 luox: −1.27 × 10−5 toolbox: −1.27 × 10−5	shiny: 79.126 luox: 1.81 × 10−5 toolbox: 1.81 × 10−5	shiny: 101.973 luox: 4.77 × 10−6 toolbox: 4.77 × 10−6	shiny: 54.413 luox: 2.47 × 10−6 toolbox: 2.47 × 10−6	shiny: 46.367 luox: 9.94 × 10−6 toolbox: 9.94 × 10−6	shiny: 671.237 luox: — toolbox: 1.22 × 10−15	shiny: 2714.135 luox: 0.00 toolbox: —	shiny: 99.784 luox: −2.16 × 10−3 toolbox: —
LED_2200K		shiny: 100.000 luox: −2.71 × 10−6 toolbox: −2.27 × 10−6	shiny: 15.044 luox: 2.38 × 10−4 toolbox: 7.77 × 10−16	shiny: 109.249 luox: 1.88 × 10−6 toolbox: −1.78 × 10−15	shiny: 167.526 luox: 1.28 × 10−6 toolbox: 2.00 × 10−15	shiny: 66.304 luox: 1.23 × 10−5 toolbox: 4.44 × 10−16	shiny: 48.778 luox: 2.14 × 10−5 toolbox: 1.89 × 10−15	shiny: 18.407 luox: 2.26 × 10−4 toolbox: −1.27 × 10−5	shiny: 75.044 luox: 2.00 × 10−5 toolbox: 1.81 × 10−5	shiny: 102.846 luox: 6.05 × 10−6 toolbox: 4.77 × 10−6	shiny: 45.736 luox: 1.48 × 10−5 toolbox: 2.47 × 10−6	shiny: 36.780 luox: 3.13 × 10−5 toolbox: 9.94 × 10−6	shiny: 329.187 luox: — toolbox: 1.55 × 10−15	shiny: 2410.988 luox: 4.61 × 10−6 toolbox: —	shiny: 87.665 luox: 4.62 × 10−4 toolbox: —
LED_4000K_1		shiny: 100.000 luox: −2.92 × 10−6 toolbox: −2.27 × 10−6	shiny: 39.460 luox: 2.61 × 10−6 toolbox: 2.66 × 10−15	shiny: 126.303 luox: 4.87 × 10−8 toolbox: 3.44 × 10−15	shiny: 162.057 luox: 4.40 × 10−8 toolbox: 6.66 × 10−15	shiny: 93.656 luox: 3.64 × 10−7 toolbox: 2.78 × 10−15	shiny: 74.836 luox: 6.17 × 10−7 toolbox: 3.00 × 10−15	shiny: 48.281 luox: −1.01 × 10−5 toolbox: −1.27 × 10−5	shiny: 86.759 luox: 1.81 × 10−5 toolbox: 1.81 × 10−5	shiny: 99.489 luox: 4.81 × 10−6 toolbox: 4.77 × 10−6	shiny: 64.603 luox: 2.83 × 10−6 toolbox: 2.47 × 10−6	shiny: 56.429 luox: 1.06 × 10−5 toolbox: 9.94 × 10−6	shiny: 300.094 luox: — toolbox: 5.44 × 10−15	shiny: 3811.887 luox: 5.90 × 10−7 toolbox: —	shiny: 82.085 luox: −4.92 × 10−4 toolbox: —
LED_4000K_2		shiny: 100.000 luox: −2.93 × 10−6 toolbox: −2.27 × 10−6	shiny: 54.816 luox: 6.77 × 10−7 toolbox: 2.44 × 10−15	shiny: 127.856 luox: 1.76 × 10−8 toolbox: 4.77 × 10−15	shiny: 164.399 luox: 1.66 × 10−8 toolbox: 4.11 × 10−15	shiny: 106.315 luox: 8.93 × 10−8 toolbox: 4.55 × 10−15	shiny: 90.404 luox: 1.32 × 10−7 toolbox: 2.55 × 10−15	shiny: 67.069 luox: −1.20 × 10−5 toolbox: −1.27 × 10−5	shiny: 87.825 luox: 1.81 × 10−5 toolbox: 1.81 × 10−5	shiny: 100.926 luox: 4.78 × 10−6 toolbox: 4.77 × 10−6	shiny: 73.336 luox: 2.56 × 10−6 toolbox: 2.47 × 10−6	shiny: 68.168 luox: 1.01 × 10−5 toolbox: 9.94 × 10−6	shiny: 338.823 luox: — toolbox: 2.33 × 10−15	shiny: 3899.370 luox: 1.72 × 10−7 toolbox: —	shiny: — luox: — toolbox: —
LED_6900K		shiny: 100.000 luox: −2.92 × 10−6 toolbox: −2.27 × 10−6	shiny: 93.998 luox: 2.39 × 10−7 toolbox: 1.67 × 10−15	shiny: 145.326 luox: 9.31 × 10−9 toolbox: 3.66 × 10−15	shiny: 161.924 luox: 1.03 × 10−8 toolbox: 4.55 × 10−15	shiny: 144.972 luox: 2.07 × 10−7 toolbox: 3.11 × 10−15	shiny: 131.440 luox: 3.24 × 10−7 toolbox: 6.66 × 10−16	shiny: 115.010 luox: −1.24 × 10−5 toolbox: −1.27 × 10−5	shiny: 99.826 luox: 1.81 × 10−5 toolbox: 1.81 × 10−5	shiny: 99.407 luox: 4.78 × 10−6 toolbox: 4.77 × 10−6	shiny: 100.001 luox: 2.67 × 10−6 toolbox: 2.47 × 10−6	shiny: 99.110 luox: 1.03 × 10−5 toolbox: 9.94 × 10−6	shiny: 351.290 luox: — toolbox: 2.11 × 10−15	shiny: 7418.690 luox: 1.36 × 10−6 toolbox: —	shiny: 93.878 luox: 3.68 × 10−5 toolbox: —
Nordhimmel		shiny: 100.000 luox: −2.93 × 10−6 toolbox: −2.27 × 10−6	shiny: 108.054 luox: 0.00 toolbox: −2.00 × 10−15	shiny: 153.329 luox: 0.00 toolbox: 4.44 × 10−15	shiny: 163.589 luox: 1.91 × 10−9 toolbox: 2.22 × 10−15	shiny: 166.521 luox: 0.00 toolbox: 5.44 × 10−15	shiny: 157.556 luox: 0.00 toolbox: 6.66 × 10−16	shiny: 132.209 luox: −1.27 × 10−5 toolbox: −1.27 × 10−5	shiny: 105.323 luox: 1.81 × 10−5 toolbox: 1.81 × 10−5	shiny: 100.429 luox: 4.77 × 10−6 toolbox: 4.77 × 10−6	shiny: 114.866 luox: 2.47 × 10−6 toolbox: 2.47 × 10−6	shiny: 118.802 luox: 9.94 × 10−6 toolbox: 9.94 × 10−6	shiny: 528.454 luox: — toolbox: 3.66 × 10−15	shiny: 9317.532 luox: 9.99 × 10−16 toolbox: —	shiny: 97.943 luox: −5.81 × 10−4 toolbox: —
Norm_TL_6500K		shiny: 100.000 luox: −2.93 × 10−6 toolbox: −2.27 × 10−6	shiny: 81.711 luox: 0.00 toolbox: −4.44 × 10−16	shiny: 145.575 luox: 0.00 toolbox: 7.77 × 10−16	shiny: 162.890 luox: 2.06 × 10−9 toolbox: 2.11 × 10−15	shiny: 144.953 luox: 0.00 toolbox: 9.99 × 10−16	shiny: 132.602 luox: 0.00 toolbox: 3.44 × 10−15	shiny: 99.976 luox: −1.27 × 10−5 toolbox: −1.27 × 10−5	shiny: 99.996 luox: 1.81 × 10−5 toolbox: 1.81 × 10−5	shiny: 100.000 luox: 4.77 × 10−6 toolbox: 4.77 × 10−6	shiny: 99.988 luox: 2.47 × 10−6 toolbox: 2.47 × 10−6	shiny: 99.986 luox: 9.94 × 10−6 toolbox: 9.94 × 10−6	shiny: 488.200 luox: — toolbox: −4.44 × 10−16	shiny: 6499.265 luox: 0.00 toolbox: —	shiny: 99.991 luox: −8.92 × 10−5 toolbox: —
The first number in every cell shows the Result from the Shiny app, the second number the relative difference of the respective result from the luox app, whereas the third number shows the same for the result from the CIE S026 Toolbox. green values indicate a zero difference, red a negative difference, and blue a positive difference. All Shiny values are rounded to three decimals. Missing values or pairwise comparisons are indicated by a —.

Results for all sources

Code

#creating the gtable -------------------

#text for the subtitle
fn_text <- md("The first number in every cell shows the Result from the *Shiny* 
              app, <br>the second number the result from the *luox* app, <br>
              whereas the third number shows the result from the *CIE S026 
              Toolbox*. <br>All values are rounded to three decimals. <br>
              Missing values are indicated by a ---.")

tt_text <- "All Results"

comparison_table(tt_text, fn_text, condition = "")

Validation Results: All Results
	Picture	Illuminance (lx)	S-cone-opic irradiance (mW ⋅ m⁻²)	M-cone-opic irradiance (mW ⋅ m⁻²)	L-cone-opic irradiance (mW ⋅ m⁻²)	Rhodopic irradiance (mW ⋅ m⁻²)	Melanopic irradiance (mW ⋅ m⁻²)	S-cone-opic EDI (lx)	M-cone-opic EDI (lx)	L-cone-opic EDI (lx)	Rhodopic EDI (lx)	Melanopic EDI (lx)	Irradiance (mW ⋅ m⁻²)	CCT (K) - Robertson, 1968	Colour Rendering Index [Ra]
EE_Spektrum		shiny: 100.000 luox: 100.000 toolbox: 100.000	shiny: 75.641 luox: 75.641 toolbox: 75.641	shiny: 139.676 luox: 139.676 toolbox: 139.676	shiny: 163.891 luox: 163.891 toolbox: 163.891	shiny: 133.005 luox: 133.005 toolbox: 133.005	shiny: 120.131 luox: 120.131 toolbox: 120.131	shiny: 92.550 luox: 92.551 toolbox: 92.551	shiny: 95.945 luox: 95.943 toolbox: 95.943	shiny: 100.614 luox: 100.614 toolbox: 100.614	shiny: 91.747 luox: 91.747 toolbox: 91.747	shiny: 90.583 luox: 90.582 toolbox: 90.582	shiny: 549.443 luox: — toolbox: 549.443	shiny: 5453.666 luox: 5453.666 toolbox: —	shiny: — luox: 95.250 toolbox: —
Fluoreszenz_NW		shiny: 100.000 luox: 100.000 toolbox: 100.000	shiny: 40.235 luox: 40.235 toolbox: 40.235	shiny: 125.328 luox: 125.328 toolbox: 125.328	shiny: 161.847 luox: 161.847 toolbox: 161.847	shiny: 90.644 luox: 90.644 toolbox: 90.644	shiny: 71.312 luox: 71.312 toolbox: 71.312	shiny: 49.229 luox: 49.230 toolbox: 49.230	shiny: 86.089 luox: 86.087 toolbox: 86.087	shiny: 99.360 luox: 99.359 toolbox: 99.359	shiny: 62.526 luox: 62.526 toolbox: 62.526	shiny: 53.772 luox: 53.771 toolbox: 53.771	shiny: 293.442 luox: — toolbox: 293.442	shiny: 3759.099 luox: 3759.099 toolbox: —	shiny: 83.077 luox: 83.000 toolbox: —
Fluoreszenz_WW		shiny: 100.000 luox: 100.000 toolbox: 100.000	shiny: 23.471 luox: 23.471 toolbox: 23.471	shiny: 111.528 luox: 111.528 toolbox: 111.528	shiny: 164.806 luox: 164.806 toolbox: 164.806	shiny: 65.329 luox: 65.329 toolbox: 65.329	shiny: 44.754 luox: 44.754 toolbox: 44.754	shiny: 28.718 luox: 28.718 toolbox: 28.718	shiny: 76.610 luox: 76.608 toolbox: 76.608	shiny: 101.176 luox: 101.176 toolbox: 101.176	shiny: 45.064 luox: 45.064 toolbox: 45.064	shiny: 33.746 luox: 33.746 toolbox: 33.746	shiny: 284.770 luox: — toolbox: 284.770	shiny: 2676.108 luox: 2676.108 toolbox: —	shiny: 82.394 luox: 82.375 toolbox: —
Halogen		shiny: 100.000 luox: 100.000 toolbox: 100.000	shiny: 22.648 luox: 22.648 toolbox: 22.648	shiny: 115.192 luox: 115.192 toolbox: 115.192	shiny: 166.103 luox: 166.103 toolbox: 166.103	shiny: 78.883 luox: 78.883 toolbox: 78.883	shiny: 61.492 luox: 61.492 toolbox: 61.492	shiny: 27.711 luox: 27.711 toolbox: 27.711	shiny: 79.126 luox: 79.125 toolbox: 79.125	shiny: 101.973 luox: 101.972 toolbox: 101.972	shiny: 54.413 luox: 54.413 toolbox: 54.413	shiny: 46.367 luox: 46.366 toolbox: 46.366	shiny: 671.237 luox: — toolbox: 671.237	shiny: 2714.135 luox: 2714.135 toolbox: —	shiny: 99.784 luox: 100.000 toolbox: —
LED_2200K		shiny: 100.000 luox: 100.000 toolbox: 100.000	shiny: 15.044 luox: 15.040 toolbox: 15.044	shiny: 109.249 luox: 109.249 toolbox: 109.249	shiny: 167.526 luox: 167.526 toolbox: 167.526	shiny: 66.304 luox: 66.303 toolbox: 66.304	shiny: 48.778 luox: 48.777 toolbox: 48.778	shiny: 18.407 luox: 18.403 toolbox: 18.407	shiny: 75.044 luox: 75.042 toolbox: 75.042	shiny: 102.846 luox: 102.845 toolbox: 102.846	shiny: 45.736 luox: 45.736 toolbox: 45.736	shiny: 36.780 luox: 36.779 toolbox: 36.780	shiny: 329.187 luox: — toolbox: 329.187	shiny: 2410.988 luox: 2410.977 toolbox: —	shiny: 87.665 luox: 87.625 toolbox: —
LED_4000K_1		shiny: 100.000 luox: 100.000 toolbox: 100.000	shiny: 39.460 luox: 39.460 toolbox: 39.460	shiny: 126.303 luox: 126.303 toolbox: 126.303	shiny: 162.057 luox: 162.057 toolbox: 162.057	shiny: 93.656 luox: 93.656 toolbox: 93.656	shiny: 74.836 luox: 74.836 toolbox: 74.836	shiny: 48.281 luox: 48.282 toolbox: 48.282	shiny: 86.759 luox: 86.757 toolbox: 86.757	shiny: 99.489 luox: 99.488 toolbox: 99.488	shiny: 64.603 luox: 64.603 toolbox: 64.603	shiny: 56.429 luox: 56.428 toolbox: 56.428	shiny: 300.094 luox: — toolbox: 300.094	shiny: 3811.887 luox: 3811.885 toolbox: —	shiny: 82.085 luox: 82.125 toolbox: —
LED_4000K_2		shiny: 100.000 luox: 100.000 toolbox: 100.000	shiny: 54.816 luox: 54.816 toolbox: 54.816	shiny: 127.856 luox: 127.856 toolbox: 127.856	shiny: 164.399 luox: 164.399 toolbox: 164.399	shiny: 106.315 luox: 106.315 toolbox: 106.315	shiny: 90.404 luox: 90.404 toolbox: 90.404	shiny: 67.069 luox: 67.070 toolbox: 67.070	shiny: 87.825 luox: 87.824 toolbox: 87.824	shiny: 100.926 luox: 100.926 toolbox: 100.926	shiny: 73.336 luox: 73.336 toolbox: 73.336	shiny: 68.168 luox: 68.167 toolbox: 68.167	shiny: 338.823 luox: — toolbox: 338.823	shiny: 3899.370 luox: 3899.370 toolbox: —	shiny: — luox: 94.625 toolbox: —
LED_6900K		shiny: 100.000 luox: 100.000 toolbox: 100.000	shiny: 93.998 luox: 93.998 toolbox: 93.998	shiny: 145.326 luox: 145.326 toolbox: 145.326	shiny: 161.924 luox: 161.924 toolbox: 161.924	shiny: 144.972 luox: 144.972 toolbox: 144.972	shiny: 131.440 luox: 131.440 toolbox: 131.440	shiny: 115.010 luox: 115.012 toolbox: 115.012	shiny: 99.826 luox: 99.824 toolbox: 99.824	shiny: 99.407 luox: 99.406 toolbox: 99.406	shiny: 100.001 luox: 100.001 toolbox: 100.001	shiny: 99.110 luox: 99.109 toolbox: 99.109	shiny: 351.290 luox: — toolbox: 351.290	shiny: 7418.690 luox: 7418.680 toolbox: —	shiny: 93.878 luox: 93.875 toolbox: —
Nordhimmel		shiny: 100.000 luox: 100.000 toolbox: 100.000	shiny: 108.054 luox: 108.054 toolbox: 108.054	shiny: 153.329 luox: 153.329 toolbox: 153.329	shiny: 163.589 luox: 163.589 toolbox: 163.589	shiny: 166.521 luox: 166.521 toolbox: 166.521	shiny: 157.556 luox: 157.556 toolbox: 157.556	shiny: 132.209 luox: 132.210 toolbox: 132.210	shiny: 105.323 luox: 105.321 toolbox: 105.321	shiny: 100.429 luox: 100.429 toolbox: 100.429	shiny: 114.866 luox: 114.866 toolbox: 114.866	shiny: 118.802 luox: 118.801 toolbox: 118.801	shiny: 528.454 luox: — toolbox: 528.454	shiny: 9317.532 luox: 9317.532 toolbox: —	shiny: 97.943 luox: 98.000 toolbox: —
Norm_TL_6500K		shiny: 100.000 luox: 100.000 toolbox: 100.000	shiny: 81.711 luox: 81.711 toolbox: 81.711	shiny: 145.575 luox: 145.575 toolbox: 145.575	shiny: 162.890 luox: 162.890 toolbox: 162.890	shiny: 144.953 luox: 144.953 toolbox: 144.953	shiny: 132.602 luox: 132.602 toolbox: 132.602	shiny: 99.976 luox: 99.978 toolbox: 99.978	shiny: 99.996 luox: 99.995 toolbox: 99.995	shiny: 100.000 luox: 100.000 toolbox: 100.000	shiny: 99.988 luox: 99.988 toolbox: 99.988	shiny: 99.986 luox: 99.985 toolbox: 99.985	shiny: 488.200 luox: — toolbox: 488.200	shiny: 6499.265 luox: 6499.265 toolbox: —	shiny: 99.991 luox: 100.000 toolbox: —
The first number in every cell shows the Result from the Shiny app, the second number the result from the luox app, whereas the third number shows the result from the CIE S026 Toolbox. All values are rounded to three decimals. Missing values are indicated by a —.

A quick overview of the previous table show that the Shiny app produces results that are either identical, or at least very similar to the luox app or the CIE Toolbox. The next two sections will provide a more concise overview of how those sources compare.

Code

#extract the relative difference differentiated by spectrum and variable
Discussion <- 
  spectra %>% 
  select(spectrum_name, excerpt) %>% 
  unnest(excerpt) %>% 
  rowwise() %>% 
  mutate(Dev_luox = 1 - Results_luox/Results_shiny,
         Dev_toolbox = 1 - Results_toolbox/Results_shiny
         ) %>% 
  ungroup()

#throwing the units out for visualization
Discussion <- 
  Discussion %>% mutate(Name = str_replace(Name, "\\(mW ⋅ m⁻²\\)", ""),
                        Name = str_replace(Name, "\\(lx\\)", ""))

Pairwise comparison to the luox app

Code

#creating a subframe for the luox-data, filtered by removing all non-comparisons
Data <- Discussion %>% dplyr::filter(!is.na(Dev_luox))
#number of comparisons made
n <- Data %>% count() %>% pull(1)
#number of comparisons split by difference
n2 <- Data %>% group_by(Dev_luox == 0, Dev_luox > 0, Dev_luox < 0) %>% 
  count() %>% pull(n)
n2[3] <- ifelse(is.na(n2[3]), "none",  n2[3])
#median difference when disregarding sign
n3 <- Data %>% filter(Dev_luox != 0) %>% 
  dplyr::summarise(median = median(abs(Dev_luox))) %>% pull(1)
#maximum difference
n4 <- Data %>% pull(Dev_luox) %>% abs() %>% max()
#where did this difference occur
n4_2 <- Data$Name[abs(Data$Dev_luox) == n4]

Of 128 comparisons, 21 were identical, 24 were smaller, and 83 were larger, using the luox results as a basis. The median relative difference was 2.93 × 10⁻⁶ (disregarding sign), i.e., 0.00029%. The highest relative difference (again disregarding sign) was 2.16 × 10⁻³ or 0.22%, which occured for Colour Rendering Index [Ra]. The following figure provides a histogram of all relative differences (excluding zero difference), colored by variable.

Overview

Code

#make a histogram of the values and calculate relevant values

breaks <- c(10^-15, 10^-10, 10^-5, 1)

Base_Plot <- 
  Data %>% filter(Dev_luox !=0) %>% 
  ggplot(aes(x=abs(Dev_luox))) +
  geom_histogram(aes(fill = Name))+
  xlab("relative difference (irregarding sign)")+
  expand_limits(x= 1)

Base_Plot +
  scale_x_log10(breaks = breaks, labels = c(vec_fmt_number(breaks*100, 
                                                           n_sigfig = 1, 
                                                           pattern = "{x}%"))) +
  ylab("no. of spectra")

Split by Variable

Code

Base_Plot +
  scale_x_log10(breaks = breaks)+
  ylab("no. of spectra")+
  facet_wrap("Name")

Split by Spectrum

Code

Base_Plot +
  scale_x_log10(breaks = breaks)+
  ylab("no. of variables")+
  facet_wrap("spectrum_name")

Pairwise comparison to the CIE Toolbox

Code

#creating a subframe for the luox-data, filtered by removing all non-comparisons
Data <- Discussion %>% dplyr::filter(!is.na(Dev_toolbox))
#number of comparisons made
n <- Data %>% count() %>% pull(1)
#number of comparisons split by difference
n2 <- Data %>% group_by(Dev_toolbox == 0, Dev_toolbox > 0, Dev_toolbox < 0) %>% 
  count() %>% pull(n)
n2[3] <- ifelse(is.na(n2[3]), "none",  n2[3])
#median difference when disregarding sign
n3 <- Data %>% filter(Dev_toolbox != 0) %>% 
  dplyr::summarise(median = median(abs(Dev_toolbox))) %>% pull(1)
#maximum difference
n4 <- Data %>% pull(Dev_toolbox) %>% abs() %>% max()
#where did this difference occur
n4_2 <- Data$Name[abs(Data$Dev_toolbox) == n4]

Of 120 comparisons, none were identical, 25 were smaller, and 95 were larger, using the CIE Toolbox results as a basis. The median relative difference was 1.13 × 10⁻⁶ (disregarding sign), i.e., 0.00011%. The highest relative difference (again disregarding sign) was 1.81 × 10⁻⁵ or 0.0018%, which occured for M-cone-opic EDI. The following figure provides a histogram of all relative differences (excluding zero difference), colored by variable.

Overview

Code

#make a histogram of the values and calculate relevant values

Base_Plot <- 
  Data %>% filter(Dev_toolbox !=0) %>% 
  ggplot(aes(x=abs(Dev_toolbox))) +
  geom_histogram(aes(fill = Name))+
  xlab("relative difference (irregarding sign)")+
  expand_limits(x= 1)

Base_Plot +
  scale_x_log10(breaks = breaks, labels = c(vec_fmt_number(breaks*100, 
                                                           n_sigfig = 1, 
                                                           pattern = "{x}%")))+
  ylab("no. of spectra")

Split by Variable

Code

Base_Plot +
  scale_x_log10(breaks = breaks)+
  ylab("no. of spectra")+
    facet_wrap("Name")

Split by Spectrum

Code

Base_Plot +
  scale_x_log10(breaks = breaks)+
  ylab("no. of variables")+
  facet_wrap("spectrum_name")

Conclusion

Overall, the agreement between the different sources is very high and differences only occur several decimals back. For most if not all of those cases, rounding errors seem a plausible explanation. In an older version of the Shiny app, negative input values for irradiance were taken at face value, i.e., they actually reduced variable values that require summation. With that state, many more comparisons showed a zero difference for the luox app, which seems to indicate that the luox app also takes negative values at face value. However, the median relative difference in that older state was about double that compared to the current state for both the luox app and the CIE Toolbox sources. Since both the overall error is reduced by the current state of the Shiny app and it is sensible to restrict input values to zero or positive numbers, this method will be used in the public release.

In summary, the Shiny app offers a sufficiently accurate calculation of ⍺-opic values, especially given its focus on education. It is of note, however, that the age corrected values could no be validated against the other two sources, since they don´t provide similar functionality.